Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ole2bm/ole2bm.bas

BASIC Source File | 1995-05-09 | 11KB | 230 lines

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' OLE2BM.BAS ver. 1.1           VB 3.0 Pro Module                rev. 5/07/94
'____________________________________________________________________________
'
' The VB 3.0 Pro code in this module provides a way to transfer bitmap data
' back and forth between a PaintBrush object within an OLE 2.0 control (use
' MSOLE2.VBX, not OLECLIENT.VBX!) and a picture box on a container form such
' that the user can edit the bitmap manually in PaintBrush along the way.
'
' This capability is useful when you wish to draw certain bitmap elements
' programmatically before or after hand editing.
'
' The considerable effort required in the support procedures below is quite
' typical of the wall one hits in attempting to gain programmatic control
' over data in embedded OLE 2.0 objects under VB.  Getting the data into the
' OLE2 control is relatively easy--getting it out is the hard part.
'
' If you know a simpler way to get the data out, I'd love to hear from you!
'
' NB: The function OleFile2Picture() buffers bitmap data in a big VB string.
' This procedure must be rewritten to handle bitmaps larger than or near 64K
' in size.
'
'   Jeremy McCreary
'   Cliffshade Computing
'   CIS [72341,3716]
'____________________________________________________________________________

Option Explicit
DefInt A-Z

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Bitmap-related constants and data structures
'____________________________________________________________________________

Global Const OLE_CREATE_EMBED = 0   ' Ole control .Action settings
Global Const OLE_ACTIVATE = 7
Global Const OLE_SAVE_TO_FILE = 11

Global Const OLE_CHANGED = 0        ' Ole control .Updated event code

Global Const SRCCOPY = &HCC0020     ' BitBlt raster op: Overwrite destination

Global Const CBM_INIT = &H4&        ' Init created DIB with the data passed
Global Const DIB_RGB_COLORS = 0     ' DIB file color tables use RGB values
Global Const OBJECT_HEADER_SIZE = 20  ' OLE file header length

Type BitmapFileHeaderType ' File header common to =all= Win 3.x .BMP files
  bfType As Integer       ' Always contains string abbreviation "BM"
  bfSize      As Long     ' Bitmap file size in bytes
  bfReserved1 As Integer  ' Set to 0  (Mouse cursor hotspot x coord)
  bfReserved2 As Integer  ' Set to 0  (Mouse cursor hotspot y coord)
  bfOffBits   As Long     ' Offset from start of this header to start of data
End Type


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Required Windows 3.1 API declarations in type-safe form.
'____________________________________________________________________________

Declare Function AnsiPrev Lib "User" (ByVal VBStr$, ByVal VBStr$) As Long
Declare Function BitBlt Lib "GDI" (ByVal DesthDC, ByVal DestX, ByVal DestY, ByVal DestWidth, ByVal DestHeight, ByVal SourcehDC, ByVal SourceX, ByVal SourceY, ByVal ROP As Long)
Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC)
Declare Function CreateDIBitmapPacked Lib "GDI" Alias "CreateDIBitmap" (ByVal hDC, ByVal lpPackedDIB&, ByVal InitFlag&, ByVal lpDataBits&, ByVal lpBitmapInfo&, ByVal ColorUse)
Declare Function DeleteDC Lib "GDI" (ByVal hDC)
Declare Function DeleteObject Lib "GDI" (ByVal hObj)
Declare Function GetTempFileName Lib "Kernel" (ByVal DriveLetterAscii, ByVal PrefixName$, ByVal Unique, ByVal NameBuffer$)
Declare Function SelectObject Lib "GDI" (ByVal hDC, ByVal hObject)

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Transfer an embedded bitmap object from an OLE 2.0 (MSOLE2.VBX) control to
' a VB picture box via the intermediaries of a temporary OLE file and a
' packed DIB memory structure.
'____________________________________________________________________________
Sub Ole2Pic (pic As PictureBox, ole As Control)
Dim f, h0, hbm, hmem, hpic, r
Dim file$, kind$

  file$ = TempFileName$("")       ' Open a temporary OLE file
  f = FreeFile
  Open file$ For Binary As f
  ole.FileNumber = f              ' Make its handle the save destination
  ole.Action = OLE_SAVE_TO_FILE   ' Save the embedded data as an OLE 2.0 file
  Close f
  kind$ = ole.Class               ' Get correct object type

  hbm = OLEFile2Picture(pic, kind$, file$) ' Extract the bitmap from the OLE file
  If hbm Then                     ' Copy the extracted DDB into picture box
    hpic = pic.hDC
    hmem = CreateCompatibleDC(hpic)
    h0 = SelectObject(hmem, hbm)  ' Select the DDB into the memory DC
    r = BitBlt(hpic, 0, 0, CInt(pic.ScaleWidth), CInt(pic.ScaleHeight), hmem, 0, 0, SRCCOPY)
    r = SelectObject(hmem, h0)    ' Restore the object previously selected
    r = DeleteObject(hbm)         ' Recover system resources
    r = DeleteDC(hmem)
    pic.Refresh                   ' Update the screen now
  End If

  Kill file$                      ' Waste the temporary OLE file

End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Copy the device-independent bitmap (DIB) contained in a PaintBrush object
' OLE 2.0 file to a packed DIB memory image, create a device-dependent bitmap
' (DDB) from the packed DIB, and return the DDB handle for future reference.
'
' NB: Once the DDB is created (i.e., once the packed DIB color table has been
' translated to the nearest available device-specific colors), subsequent
' display of the bitmap goes =much= faster than if displayed directly as a
' packed DIB, say with StretchDIBits().
'____________________________________________________________________________
Function OLEFile2Picture (pic As PictureBox, kind$, OLEfile$)
Dim hbm, hOLE, k
Dim buffers As Long, bytes As Long, ptr As Long, remainder As Long
Dim BitmapOffset As Long, lpDataBits As Long, lpPackedDIB As Long
Dim buffer$, PackedDIB$
Dim bfh As BitmapFileHeaderType
Const BUFFER_SIZE = 8192              ' File input buffer length
Const STRING_LIMIT = 65500
Const MB = 16                         ' Stop style MsgBox

  hOLE = FreeFile                     ' Open the source OLE file
  Open OLEfile$ For Binary As hOLE

  If LOF(hOLE) > OBJECT_HEADER_SIZE Then
    buffer$ = Space$(BUFFER_SIZE)
    Get hOLE, 1, buffer$              ' Get first bufferfull of OLE file data
    ptr = InStr(buffer$, kind$)       ' Look for a correct object class name
    If ptr Then                       ' Find the bitmap's starting offset
      BitmapOffset = InStr(ptr, buffer$, "BM")
      If BitmapOffset Then            ' Read the embedded bitmap file
        Get hOLE, BitmapOffset, bfh   ' Read the bitmap file header
        bytes = bfh.bfSize - Len(bfh) ' Calculate number of buffers needed
        If bytes > STRING_LIMIT Then  ' Can't use a VB string buffer
            MsgBox "Sorry, your bitmap is too large to buffer in a VB string.", MB, "OLE2 File Error"
            GoTo OLEFile2PictureExit  ' Beat feet
        Else                          ' Initialize string to eventual size to
            PackedDIB$ = Space$(bytes) ' avoid "Out of string space" error
        End If
        buffer$ = Space$(BUFFER_SIZE)
        buffers = bytes \ BUFFER_SIZE
        remainder = bytes Mod BUFFER_SIZE
        ptr = 1&                      ' ptr -> 1st byte of bitmapinfo header
        Do Until ptr > bytes - remainder ' Build up a packed DIB memory image in
          Get hOLE, , buffer$            '  a VB string, 1 bufferfull at a time
          Mid$(PackedDIB$, ptr, BUFFER_SIZE) = buffer$
          ptr = ptr + BUFFER_SIZE
        Loop
        buffer$ = Space$(remainder)   ' Now get what's left
        Get hOLE, , buffer$
        Mid$(PackedDIB$, ptr) = buffer$
        lpPackedDIB = SSegAddr(PackedDIB$) ' Get a long pointer to packed DIB
        lpDataBits = lpPackedDIB + bfh.bfOffBits - Len(bfh)  ' and data bits
      ' Create a device-dependent bitmap (DDB) compatible with the target
      ' picture box device context.
        hbm = CreateDIBitmapPacked(pic.hDC, lpPackedDIB, CBM_INIT, lpDataBits, lpPackedDIB, DIB_RGB_COLORS)